home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / amiga-menu.el < prev    next >
Lisp/Scheme  |  1992-05-16  |  5KB  |  136 lines
  1. ;(provide 'amiga-menu)
  2.  
  3. (defconst amiga-menu-pick (char-to-string 3))
  4. (defconst amiga-menu-help (char-to-string 7))
  5.  
  6. (defvar amiga-menus-description nil
  7.   "Variable containing the menus setup for Emacs")
  8.  
  9. (defun amiga-menus-set (menus)
  10.   "Setup menus for emacs (parameter as for amiga-menus)"
  11.   (define-key mouse-map amiga-menu-pick 'amiga-menus-dispatch)
  12.   (define-key mouse-map amiga-menu-help 'amiga-menus-help)
  13.   (setq amiga-menus-description menus)
  14.   (amiga-menus menus))
  15.  
  16. (defun amiga-menus-dispatch (selection)
  17.   (let* ((menu (car selection))
  18.      (item (cadr selection))
  19.      (code (cadr (nth item (cadr (nth menu amiga-menus-description))))))
  20.     (if (and (listp code) (eq (car code) 'call-interactively)
  21.          (listp (cadr code)) (eq (car (cadr code)) 'quote))
  22.     (setq this-command (cadr (cadr code))))
  23.     (eval code)))
  24.  
  25. (defun amiga-menus-help (selection)
  26.   (let* ((menu (car selection))
  27.      (item (cadr selection))
  28.      (cmd (cadr (nth item (cadr (nth menu amiga-menus-description))))))
  29.     (if (and (listp cmd) (eq (car cmd) 'call-interactively)
  30.          (listp (car (cdr cmd))) (eq (car (car (cdr cmd))) 'quote))
  31.     (describe-function (car (cdr (car (cdr cmd)))))
  32.     (error "Don't know how to describe %s" cmd))))
  33.  
  34. (defun make-explicit-string (str)
  35.   (if (and (>= (length str) 2) (= (elt str 0) 27) (< (elt str 1) 128))
  36.       (key-description (concat (char-to-string (+ 128 (elt str 1)))
  37.                    (substring str 2)))
  38.       (key-description str)))
  39.  
  40. (defun make-command-name (command str width)
  41.   (let ((keys (where-is-internal command nil t))
  42.     (string (if str str (symbol-name command))))
  43.     (if keys
  44.     (format (if width (format "%%-%ds%%s" (+ width 2)) "%s (%s)")
  45.         string (make-explicit-string keys))
  46.     string)))
  47.  
  48. (defun menu-items (commands proportional)
  49.   (let* ((width (if proportional nil 0))
  50.      (names (mapcar
  51.          (function (lambda (cmd)
  52.                  (if cmd
  53.                  (let* ((name (if (symbolp cmd)
  54.                           (symbol-name cmd)
  55.                           (car cmd)))
  56.                     (len (length name)))
  57.                    (if (and (not proportional) (> len width))
  58.                        (setq width len))
  59.                    name))))
  60.          commands)))
  61.     (mapcar
  62.      (function (lambda (cmd)
  63.          (let ((name (car names)))
  64.            (setq names (cdr names))
  65.            (if cmd
  66.                (let ((command (if (symbolp cmd) cmd (cadr cmd))))
  67.              (list (make-command-name command name width)
  68.                    (list 'call-interactively (list 'quote command))
  69.                    (caddr cmd)))))))
  70.      commands)))
  71.  
  72. (defun convert-menu-buffer (proportional)
  73.   "Convert the current buffer into a loadable menu file for emacs.\n\
  74. If PROPORTIONAL is true (or if a prefix arg is given), assume menu is in a \n\
  75. proportional font & present it differently."
  76.   (interactive "P")
  77.   (save-buffer)
  78.   (widen)
  79.   (goto-char 1)
  80.   (let ((menu-spec (reverse (read (current-buffer))))
  81.     menu-code)
  82.     (while menu-spec
  83.       (let ((menu-item (car menu-spec)))
  84.     (setq menu-code
  85.           (cons (list (car menu-item)
  86.               (menu-items (cdr menu-item) proportional))
  87.             menu-code))
  88.     (setq menu-spec (cdr menu-spec))))
  89.     (let ((new-buf
  90.        (find-file (concat
  91.                (substring (buffer-file-name) 0
  92.                   (string-match "\\.menu$" (buffer-file-name)))
  93.                ".el"))))
  94.       (erase-buffer)
  95.       (prin1 (list 'amiga-menus-set (list 'quote menu-code)) (current-buffer))
  96.       (beginning-of-buffer))))
  97.  
  98. (defvar menu-mode-syntax-table nil
  99.   "Syntax table used while in menu mode.")
  100.  
  101. (defvar menu-mode-abbrev-table nil
  102.   "Abbrev table used while in menu mode.")
  103. (define-abbrev-table 'menu-mode-abbrev-table ())
  104.  
  105. (if menu-mode-syntax-table
  106.     ()
  107.   (setq menu-mode-syntax-table (make-syntax-table))
  108.   (modify-syntax-entry ?' "w   " menu-mode-syntax-table))
  109.  
  110. (defvar menu-mode-map ())
  111. (if menu-mode-map
  112.     ()
  113.   (setq menu-mode-map (make-sparse-keymap))
  114.   (define-key menu-mode-map "\t" 'indent-relative)
  115.   (define-key menu-mode-map "\C-c\C-c" 'convert-menu-buffer))
  116.  
  117. (defun menu-mode ()
  118.   "Major mode for editing menus intended for humans to read.
  119. Indentation works like in indented-text-mode. This could be improved.\\{menu-mode-map}
  120. Turning on menu-mode calls the value of the variable menu-mode-hook,
  121. if that value is non-nil."
  122.   (interactive)
  123.   (kill-all-local-variables)
  124.   (use-local-map menu-mode-map)
  125.   (define-abbrev-table 'menu-mode-abbrev-table ())
  126.   (setq local-abbrev-table menu-mode-abbrev-table)
  127.   (set-syntax-table menu-mode-syntax-table)
  128.   (make-local-variable 'indent-line-function)
  129.   (setq indent-line-function 'indent-relative-maybe)
  130.   (use-local-map menu-mode-map)
  131.   (setq mode-name "Menu")
  132.   (setq major-mode 'menu-mode)
  133.   (run-hooks 'menu-mode-hook))
  134.  
  135. (setq auto-mode-alist (cons '("\\.menu$" . menu-mode) auto-mode-alist))
  136.